Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbdb/dbaccess.bas

BASIC Source File | 1995-09-06 | 16KB | 600 lines

'
'VBDB version 1.0 for Visual Basic 1.0 and Windows 3.0
'(C)1991 Marquis Computing. All Rights Reserved.
'
'Client interface module for VBDB version 1.10.
'

DefInt A-Z

Dim DBA_Data  As String
Dim DBA_Mesg  As String
Dim DBA_Stat  As Integer
Dim ClientID As String

Const True = -1
Const False = 0

Sub StatusDBF (Handle, FileName$, dbftype$, DBTPtr, NumRecs&, NumFlds, RecLen, UpDate$, Status)

    '
    'Returns information about a database
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "STATUSDBF," + Str$(Handle)

    '--- return values
    If Status = 0 Then
        ReDim Parsed(8)  As String
        ParseString DBA_Data, ",", Parsed()
        FileName$ = Parsed(1)
        dbftype$ = Parsed(2)
        DBTPtr = Val(Parsed(3))
        NumRecs& = Val(Parsed(4))
        NumFlds = Val(Parsed(5))
        RecLen = Val(Parsed(6))
        UpDate$ = Parsed(7)
    End If

End Sub

Sub CloseDBF (Handle, Status, Mode)

    '
    'Asks the DDE server to close a database file
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CLOSEDBF," + Str$(Handle) + "," + Str$(Mode)     'use DDE

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CloseNDX (Index, Status)
    '
    'Closes an index
    '

    '--- verify handle is valid
    If Index < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CLOSENDX," + Str$(Index)

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CommitSTR (Handle, Status)

    '
    'Used to write the database header to disk
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "CREATEDBF," + Str$(Handle)    'use DDE

    '--- return value(s)
    Status = DBA_Stat                       'set status

End Sub

Sub CreateDBF (NewDbfName$, Handle, Fld$(), Mode, Status)

    '
    'High level routine to create a then
    'open a database. Combines the functions of
    '
    '   OpenDBF,
    '   DefineSTR,
    '   CommitSTR,
    '   CloseDBF and
    '   OpenDBF
    '
    'all in one routine.
    '
    'NOTE:  Database is defined based on array Flds$().
    '       I strongly urge you to use DefineDatabase
    '       to develop the Flds$() definition array
    '       for you!
    '
    '

    '--- open file / erase exiting (if any)
    OpenDBF Handle, Status, NewDbfName$, dbftype, 2
    If Status Then Exit Sub

    '--- get no. fields
    NumFlds = Val(Fld$(0, 0))

    '--- add fields
    For FldNum = 1 To NumFlds
        FldName$ = LTrim$(RTrim$(UCase$(Fld$(FldNum, 4))))
        FldType$ = Left$(UCase$(Fld$(FldNum, 3)), 1)
        FldLen = Val(Fld$(FldNum, 2))
        Dec = Val(Fld$(FldNum, 1))
        DefineSTR Handle, FldNum, FldName$, FldType$, FldLen, Dec
    Next

    '--- save structure to file
    CommitSTR Handle, Status

    '--- close it
    CloseDBF Handle, Status, 0

    '--- open it up
    OpenDBF Handle, Status, NewDbfName$, dbftype, Mode

End Sub

Sub DBAccess (CmdStr$)

    '
    'Low-level routine which actually does the DDE
    'exchange with the server.
    '

    '--- check link
    'If Not DBALinkUp() Then Exit Sub

    '--- send DDE command
    DBA.db.LinkExecute CmdStr$

    '--- assign server response(s)
    DBA_Data = DBA.db.Text
    DBA_Mesg = DBA.message.Text
    DBA_Stat = Val(DBA.errorstat.Text)

End Sub

Function DBALinkUp ()

    '
    'Returns True (-1) if a client-server database link
    'is up, False (0) if link is down.
    '

    On Error GoTo LinkUpError
    DBA.db.LinkExecute "Status"
    DBALinkUp = -1
    On Error GoTo 0
    Exit Function

LinkUpError:
    DBALinkUp = 0
    On Error GoTo 0
    Resume LinkUpErrorOut
LinkUpErrorOut:
End Function

Function DBALoaded ()

    '
    'Checks to see if server is already running --
    'use DBALinkUp to see if DDE channel is
    'operational.
    '

    On Error GoTo VBDBLoadedError
    AppActivate "VBDB"
    On Error GoTo 0
    DBALoaded = -1
    Exit Function

VBDBLoadedError:
    On Error GoTo 0
    DBALoaded = 0
    Resume VBDBLoadedErrorOut

VBDBLoadedErrorOut:

End Function

Sub DefineSTR (Handle, FldNum, FldName$, FldType$, FldLen, Decimal)

    '
    'Used to send information to the DDE server to
    'define a database. It called once for each field.
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "DEFSTR," + Str$(Handle) + "," + Str$(FldNum) + "," + FldName$ + "," + FldType$ + "," + Str$(FldLen) + "," + Str$(Decimal)

    '--- return value(s)
    Status = DBA_Stat

End Sub

Sub GetFLD (Handle, Status, FldNum, FldName$, FldData$, RecData$)

    '
    'Returns a fields data from a database. FldNum has precedence
    'over FldName$. FldNum indicates a field number to retrieve,
    'if FldNum > 0. FldName$ indicates a field name to get, if FldNum
    'is 0.
    '
    'Returns FldNum, FldName$, FldData$ and Status
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETFLD," + Str$(Handle) + "," + Str$(FldNum) + "," + FldName$ + "," + RecData$

    '--- return value(s)
    FldData$ = DBA_Data
    Status = DBA_Stat

End Sub

Sub GetFLDS (Handle, Status, NumFlds, Flds$(), RecNum&)
    '
    'Returns the number of fields in a record and
    'parses the record into an array. Faster than
    'Using GetREC and then using multiple GetFLD
    'calls. Passed RecNum& -- returns Flds$() which contains
    'all the fields data.
    '
    DBAccess "GETFLDS," + Str$(Handle) + "," + Str$(RecNum&)
    Status = DBA_Stat: If Status > 0 Then Exit Sub
    ParseString DBA_Data, ",", Flds$()
    NumFlds = Val(Flds$(1))
    For X = 1 To NumFlds - 1
        Flds$(X) = Flds$(X + 1)
    Next
End Sub

Sub GetKEY (Index, Status, Key$, Record&, Mode)

    '
    'Finds a key in an index
    '

    '--- verify handle is valid
    If Index < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETKEY," + Str$(Index) + "," + Key$ + "," + Str$(Record&) + "," + Str$(Mode)

    '--- return value(s)
    If DBA_Mesg = "key found" Then
        Record& = DBA_Stat              'record no. passed via stat
        DBA_Stat = 0                    'status is 0
        Status = 0                      '   "    " "
    Else
        Status = DBA_Stat
    End If

    Key$ = DBA_Data                 'actual key found

End Sub

Sub GetREC (Handle, Status, Rec&, RecData$)

    '
    'Returns a DBF record from Handle in RecData$
    '

    '--- verify handle is valid
    If Handle < 1 Then Status = 5: Exit Sub

    '--- use DDE Server
    DBAccess "GETREC," + Str$(Handle) + "," + Str$(Rec&)

    '--- return value(s)
    RecData$ = DBA_Data
    Status = DBA_Stat

End Sub

Function InCount (StringToCount As String, Item As String) As Integer

        '
        'Counts up the number of times Item$ occurs in StringToCount$.
        '
        'Another interesting (to me) use of extra code to speed up a
        'time-critical operation. Below, I use code short-circuiting
        'techniques as well as loop counter modification and STEP
        'options to make this FOR...NEXT loop the FASSSSTEST it can
        'be!
        '

        '--- Get these now to save time later
        Reps = Len(StringToCount$)      'size of string
        ItemLen = Len(Item$)               'use this to be able to find blocks

        '--- go for it
        For X = 1 To Reps Step ItemLen     'STEP Item for speed!
          '--- look for Item$
          OffSet = InStr(X, StringToCount$, Item$)
          If OffSet Then